home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / PASCAL / XTREEM01.ZIP / XTREEM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-04-18  |  14.6 KB  |  410 lines
  1. unit XTreem;   {by Sean Palmer}
  2. {with a little help from:
  3.    Matt Pritchard, Bas Van Gaalen, Michael Abrash, Keld Hansen, Bresenham}
  4. {public domain}
  5. {credit me if you use any of this}
  6.  
  7. interface
  8.  
  9. {A physical display mode is formed by combining a table for the desired
  10. horizontal resolution with a table for the desired vertical resolution.
  11. Logical screen resolutions can be greater than physical resolutions, and
  12. if so, window scrolling is possible. The total memory required by a mode
  13. is (logXRes*logYRes)div 4, and cannot exceed 64k. If more than one page
  14. will fit in 64k, you can use page flipping to get smoother animation.
  15. Some modes or combinations of modes may fry your monitor or whatnot, I
  16. make no guarantees about any of these modes. Use them at your own risk.
  17. Some are more stable than others.}
  18.  
  19. {HORIZONTAL MODES}
  20.     {low byte of crtc data indicates the following crtc registers:}
  21.     {00=H total}
  22.     {01=H displayed}
  23.     {02=H start blank}
  24.     {03=H end blank}
  25.     {04=H start sync}
  26.     {05=H end sync}
  27. {format for table: hRes, miscReg, crtc regs, 0}
  28.   {Dot clocks available for miscReg: (3=25MHz,7=28MHz,$B=reserved) }
  29.   {This also has the effect of forcing the VGA to use $3Dx port addresses}
  30. {any VGA should be able to handle these first 2 horizontal modes}
  31. const mode320x:array[0..02]of word=(320,$03,0);
  32. const mode360x:array[0..08]of word=(360,$07,$6B00,$5901,$5A02,$8E03,$5E04,$8A05,0);
  33. {the following modes are nonstandard and should be used with extreme caution!}
  34. const mode256x:array[0..08]of word=(256,$03,$5F00,$3F01,$4002,$8203,$4E04,$9A05,0);
  35. const mode376x:array[0..08]of word=(376,$07,$6E00,$5D01,$5E02,$9103,$6204,$8F05,0);
  36. {I made these myself. See above warning.}
  37. const mode128x:array[0..08]of word=(128,$03,$2D00,$1F01,$2002,$9003,$2404,$8F05,0);
  38. const mode264x:array[0..08]of word=(264,$03,$6100,$4101,$4202,$8403,$5004,$9C05,0);
  39. const mode304x:array[0..08]of word=(304,$03,$5B00,$4B01,$4C02,$9E03,$5004,$1C05,0);
  40. const mode312x:array[0..08]of word=(312,$03,$5D00,$4D01,$4E02,$8003,$5204,$9E05,0);
  41. const mode328x:array[0..08]of word=(328,$07,$6300,$5101,$5202,$8603,$5604,$8205,0);
  42. const mode336x:array[0..08]of word=(336,$07,$6500,$5301,$5402,$8803,$5804,$8405,0);
  43. const mode344x:array[0..08]of word=(344,$07,$6700,$5501,$5602,$8A03,$5A04,$8605,0);
  44. const mode352x:array[0..08]of word=(352,$07,$6900,$5701,$5802,$8C03,$5C04,$8805,0);
  45. const mode368x:array[0..08]of word=(368,$07,$6C00,$5B01,$5C02,$8903,$6004,$8D05,0);
  46. const mode384x:array[0..08]of word=(384,$07,$7000,$5F01,$6002,$9303,$6404,$9105,0);
  47. const mode392x:array[0..08]of word=(392,$07,$7200,$6101,$6202,$9503,$6604,$9305,0);
  48. const mode400x:array[0..08]of word=(400,$07,$7200,$6301,$6302,$9503,$6704,$9305,0);
  49.  
  50. {VERTICAL MODES}
  51.     {low byte of crtc data indicates the following crtc registers:}
  52.     {06=V total}
  53.     {07=overflow}
  54.     {09=cell height/max scan, doubling on}
  55.     {10=V start retrace}
  56.     {11=V end retrace and protect}
  57.     {12=V display enable end}
  58.     {15=V start blank}
  59.     {16=V end blank}
  60. {format for table: vRes, miscReg, crtc regs, 0}
  61.   {lines available for miscReg: ($A0=350,$60=400,$E0=480)}
  62. {any VGA should be able to handle these first 4 vertical modes}
  63. const mode200y:array[0..02]of word=(200,$60,0);
  64. const mode240y:array[0..09]of word=(240,$E0,$0D06,$3E07,$EA10,$AC11,$DF12,$E715,$0616,0);
  65. const mode400y:array[0..03]of word=(400,$60,$4009,0);
  66. const mode480y:array[0..10]of word=(480,$E0,$0D06,$3E07,$4009,$EA10,$AC11,$DF12,$E715,$0616,0);
  67. {the following modes are nonstandard and should be used with extreme caution!}
  68. const mode256y:array[0..10]of word=(256,$E0,$2306,$B207,$6109,$0A10,$AC11,$FF12,$0715,$1716,0);
  69. const mode282y:array[0..10]of word=(282,$E0,$6206,$E007,$6109,$3710,$0911,$3312,$3C15,$5C16,0);
  70. const mode308y:array[0..10]of word=(308,$E0,$6206,$0F07,$4009,$3710,$8911,$3312,$3C15,$5C16,0);
  71. const mode360y:array[0..08]of word=(360,$E0,            $4009,$8810,$8511,$6712,$6D15,$BA16,0);{gap}
  72. const mode564y:array[0..10]of word=(564,$E0,$6206,$E007,$6009,$3710,$0911,$3312,$3C15,$5C16,0);
  73. {I made these myself. See above warning.}
  74. const mode64y: array[0..10]of word=( 64,$E0,$2306,$B207,$6709,$0A10,$AC11,$FF12,$0715,$1716,0);
  75. const mode90y: array[0..08]of word=( 90,$E0,            $4309,$8810,$8511,$6712,$6D15,$BA16,0);{gap}
  76. const mode94y: array[0..10]of word=( 94,$E0,$6206,$E007,$6509,$3710,$0911,$3312,$3C15,$5C16,0);
  77. const mode100y:array[0..03]of word=(100,$60,$4309,0);
  78. const mode120y:array[0..10]of word=(120,$E0,$0D06,$3E07,$4309,$EA10,$AC11,$DF12,$E715,$0616,0);
  79. const mode128y:array[0..10]of word=(128,$E0,$2306,$B207,$6309,$0A10,$AC11,$FF12,$0715,$1716,0);
  80. const mode141y:array[0..10]of word=(141,$E0,$6206,$E007,$6309,$3710,$0911,$3312,$3C15,$5C16,0);
  81. const mode154y:array[0..10]of word=(154,$E0,$6206,$0F07,$4109,$3710,$8911,$3312,$3C15,$5C16,0);
  82. const mode180y:array[0..08]of word=(180,$E0,            $4109,$8810,$8511,$6712,$6D15,$BA16,0);{gap}
  83. const mode188y:array[0..10]of word=(188,$E0,$6206,$E007,$6209,$3710,$0911,$3312,$3C15,$5C16,0);
  84. const mode512y:array[0..10]of word=(512,$E0,$2306,$B207,$6009,$0A10,$AC11,$FF12,$0715,$1716,0);
  85.  
  86. {I also have an X640X400 unit that uses a VESA tweak to get 640x400x256 mode X}
  87. {If anyone has any other CRTC values that work, such as 600y or 160x, drop me
  88.  a line at sean.palmer@delta.com}
  89.  
  90. var
  91.   xRes:word;            {width of physical screen in pixels}
  92.   yRes:word;            {height of physical screen in pixels}
  93.   lxRes:word;           {width of virtual screen in pixels}
  94.   lyRes:word;           {height of virtual screen in pixels}
  95.  
  96. {these provided for low-level external routines}
  97. const
  98.   seqPort=$3C4;         {VGA Sequencer}
  99. var
  100.   lxBytes:word;         {width of virtual screen in bytes per plane}
  101.   pgBytes:word;         {size of a page in bytes per plane}
  102.   pgStart:pointer;      {offset of current write page in bytes}
  103.   pgShown:pointer;      {offset of currently visible display page in bytes}
  104.  
  105. var yTab:array[0..563]of word; {scan line lookup table. Big enough to handle 564 rows}
  106.  
  107. type tSpriteHeader=record
  108.   width,height,hOfs,vOfs:word;
  109.   end; {sprite data follows}
  110.  
  111. procedure clear(color:byte);
  112. procedure plot(x,y:word; color:byte);
  113. function  scrn(x,y:word):byte;
  114. procedure hlin(x,x2,y:word; color:byte);
  115. procedure vlin(x,y,y2:word; color:byte);
  116. procedure rect(x,y,x2,y2:word; color:byte);
  117. procedure pane(x,y,x2,y2:word; color:byte);
  118. procedure line(x,y,x2,y2:word; color:byte);
  119. procedure curve(x1,y1,x2,y2,x3,y3:integer; color:byte; steps:word);
  120. procedure circle(xc,yc:integer; r:word; color:byte);
  121. procedure oval(xc,yc,a,b:integer; color:byte);
  122. procedure disk(xc,yc,a,b:integer; color:byte);
  123. procedure fill(x,y:integer; color:byte);
  124.  
  125. procedure polygon(var pts; count:word; c:byte);
  126.  
  127. procedure drawSprite(var sprite; x,y:integer);
  128. procedure drawTile(var tile; x,y:integer);
  129.  
  130. procedure setColor(color,r,g,b:byte); {rgb vals are from 0-63}
  131. function  getColor(color:byte):longint; {returns $00rrggbb format}
  132. procedure setPalette(color:byte;num:word;var rgb); {rgb is list of 3-byte rgb vals}
  133. procedure getPalette(color:byte;num:word;var rgb);
  134.  
  135. procedure memBlt(memPage:pointer);
  136. procedure pageFlip;
  137. procedure setWritePage(adr:word);
  138. procedure setDisplayPage(adr:word);
  139. procedure setWindow(x,y:integer);
  140.  
  141. procedure waitRetrace;
  142. procedure setSplitScreen(adr:word);
  143.  
  144. function  setModeX(var tblX,tblY; logX,logY:word):boolean;
  145. procedure setText;
  146.  
  147. function  rgb(r,g,b:byte):byte;
  148. procedure setUniformPalette;
  149.  
  150. var exitMsg:string[80];
  151.  
  152. implementation
  153.  
  154. {$L XTREEM.OBJ}
  155.  
  156. procedure clear(color:byte);external;
  157. procedure plot(x,y:word;color:byte);external;
  158. function  scrn(x,y:word):byte;external;
  159. procedure hLin(x,x2,y:word; color:byte);external;
  160. procedure vLin(x,y,y2:word; color:byte);external;
  161.  
  162. procedure rect(x,y,x2,y2:word; color:byte);begin
  163.   hlin(x,x2,y,color);
  164.   hlin(x,x2,y2,color);
  165.   vlin(x,y+1,y2-1,color);
  166.   vlin(x2,y+1,y2-1,color);
  167.   end;
  168.  
  169. procedure pane(x,y,x2,y2:word; color:byte);external;
  170.  
  171. procedure line(x,y,x2,y2:word; color:byte);
  172. var d,dx,dy,ai,bi,xi,yi:integer;
  173. begin
  174.   if(x<x2)then begin xi:=1;dx:=x2-x;end else begin xi:=-1;dx:=x-x2;end;
  175.   if(y<y2)then begin yi:=1;dy:=y2-y;end else begin yi:=-1;dy:=y-y2;end;
  176.   plot(x,y,color);
  177.   if (dx or dy=0)then exit;
  178.   if dx>dy then begin ai:=(dy-dx)*2;bi:=dy*2; d:=bi-dx;
  179.    repeat
  180.     if(d>=0)then begin inc(y,yi);inc(d,ai);end else inc(d,bi);
  181.     inc(x,xi);
  182.     if (x>=0) and (y<lxRes)and(y>=0)and(y<lyRes) then
  183.     plot(x,y,color);
  184.     until(x=x2);
  185.    end
  186.   else begin ai:=(dx-dy)*2;bi:=dx*2; d:=bi-dy;
  187.    repeat
  188.     if(d>=0)then begin inc(x,xi);inc(d,ai);end else inc(d,bi);
  189.     inc(y,yi);
  190.     if (x>=0) and (y<lxRes)and(y>=0)and(y<lyRes) then
  191.     plot(x,y,color);
  192.     until(y=y2);
  193.    end;
  194.   end;
  195.  
  196. procedure curve(x1,y1,x2,y2,x3,y3:integer; color:byte; steps:word);external;
  197.  
  198. procedure circle(xc,yc:integer; r:word; color:byte);external;
  199.  
  200. procedure oval(xc,yc,a,b:integer;color:byte);
  201. var x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;
  202. begin
  203.  x:=0;y:=b; aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;
  204.  d:=bb-aa*b+aa div 4; dx:=0;dy:=aa2*b;
  205.  plot(xc,yc-y,color);plot(xc,yc+y,color);
  206.  plot(xc-a,yc,color);plot(xc+a,yc,color);
  207.  while(dx<dy)do begin
  208.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  209.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  210.   plot(xc+x,yc+y,color); plot(xc-x,yc+y,color);
  211.   plot(xc+x,yc-y,color); plot(xc-x,yc-y,color);
  212.   end;
  213.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  214.  while(y>0)do begin
  215.   if(d<0)then begin inc(x); inc(dx,bb2); inc(d,bb+dx); end;
  216.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  217.   plot(xc+x,yc+y,color); plot(xc-x,yc+y,color);
  218.   plot(xc+x,yc-y,color); plot(xc-x,yc-y,color);
  219.   end;
  220.  end;
  221.  
  222. procedure disk(xc,yc,a,b:integer;color:byte);
  223. var x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;
  224. begin
  225.  x:=0;y:=b; aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;
  226.  d:=bb-aa*b+aa div 4; dx:=0;dy:=aa2*b;
  227.  vLin(xc,yc-y,yc+y,color);
  228.  while(dx<dy)do begin
  229.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  230.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  231.   vLin(xc-x,yc-y,yc+y,color);vLin(xc+x,yc-y,yc+y,color);
  232.   end;
  233.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  234.  while(y>=0)do begin
  235.   if(d<0)then begin
  236.    inc(x); inc(dx,bb2); inc(d,bb+dx);
  237.    vLin(xc-x,yc-y,yc+y,color);vLin(xc+x,yc-y,yc+y,color);
  238.    end;
  239.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  240.   end;
  241.  end;
  242.  
  243. var fillVal:byte;
  244. {This routine only called by fill}
  245. function lineFill(x,y,d,prevXL,prevXR:integer;color:byte):integer;var xl,xr,i:integer;label _1,_2,_3;begin
  246.  xl:=x;xr:=x;
  247.  repeat dec(xl); until(scrn(xl,y)<>fillVal)or(xl<0); inc(xl);
  248.  repeat inc(xr); until(scrn(xr,y)<>fillVal)or(xr>=xRes); dec(xr);
  249.  hLin(xl,xr,y,color);
  250.  inc(y,d);
  251.  if word(y)<yRes then
  252.   for x:=xl to xr do
  253.    if(scrn(x,y)=fillVal)then begin
  254.     x:=lineFill(x,y,d,xl,xr,color);
  255.     if word(x)>xr then goto _1;
  256.     end;
  257. _1:dec(y,d+d); asm neg d;end;
  258.  if word(y)<yRes then begin
  259.   for x:=xl to prevXL do
  260.    if(scrn(x,y)=fillVal)then begin
  261.     i:=lineFill(x,y,d,xl,xr,color);
  262.     if word(x)>prevXL then goto _2;
  263.     end;
  264. _2:for x:=prevXR to xr do
  265.    if(scrn(x,y)=fillVal)then begin
  266.     i:=lineFill(x,y,d,xl,xr,color);
  267.     if word(x)>xr then goto _3;
  268.     end;
  269. _3:end;
  270.  lineFill:=xr;
  271.  end;
  272.  
  273. procedure fill(x,y:integer;color:byte);begin
  274.  fillVal:=scrn(x,y);if fillVal<>color then lineFill(x,y,1,x,x,color);
  275.  end;
  276.  
  277.  
  278. function maxi(a,b:integer):integer; inline(
  279.   $58/             { pop   ax     }
  280.   $5b/             { pop   bx     }
  281.   $3b/$c3/         { cmp   ax,bx  }
  282.   $7f/$01/         { jg    +1     }
  283.   $93);            { xchg  ax,bx  }
  284.  
  285. function mini(a,b:integer):integer; inline(
  286.   $58/             { pop   ax     }
  287.   $5b/             { pop   bx     }
  288.   $3b/$c3/         { cmp   ax,bx  }
  289.   $7c/$01/         { jl    +1     }
  290.   $93);            { xchg  ax,bx  }
  291.  
  292. procedure calcEdge(x,y,x2,y2:integer; var table);near;external;
  293.  
  294. procedure rowList(startY,count:word; var tbl;color:byte);far;external;
  295.  
  296. procedure polygon(var pts; count:word; c:byte);
  297. var i,i2,ly,gy,y:integer; pos:array[0..563,0..1] of integer;
  298. var p:array[0..99]of record x,y:integer end absolute pts;
  299. begin
  300.   ly:=lyRes; gy:=-1;
  301.   for i:=count-1 downto 0 do with p[i] do begin
  302.     ly:=maxi(mini(ly,y),0);     {determine high and low range}
  303.     gy:=mini(maxi(gy,y),lyRes-1);
  304.     if i=0 then i2:=count-1 else i2:=i-1;
  305.     calcEdge(p[i2].x,p[i2].y,x,y,pos);
  306.     end;
  307.   if (ly<lyRes)and(gy>=0) then  { vertical offscreen checking }
  308.     rowlist(ly,gy-ly+1,pos,c);
  309.   end;
  310.  
  311. procedure drawSprite(var sprite; x,y:integer);external;
  312. procedure drawTile(var tile; x,y:integer);external;
  313. procedure setColor(color,r,g,b:byte);external;
  314. function getColor(color:byte):longint;external;
  315.  
  316. procedure setPalette(color:byte;num:word;var rgb);external;
  317. procedure getPalette(color:byte;num:word;var rgb);external;
  318.  
  319. procedure setSplitScreen(adr:word); assembler;
  320. asm
  321.   mov dx,3D4h  {crtcPort}
  322.   mov al,18h
  323.   mov ah,[byte(adr)]
  324.   out dx,ax
  325.   mov al,7
  326.   out dx,al
  327.   inc dx
  328.   in al,dx
  329.   dec dx
  330.   mov ah,[byte(adr)+1]
  331.   and ah,00000001b
  332.   shl ah,4
  333.   and al,11101111b
  334.   or al,ah
  335.   mov ah,al
  336.   mov al,7
  337.   out dx,ax
  338.  
  339.   mov al,9
  340.   out dx,al
  341.   inc dx
  342.   in al,dx
  343.   dec dx
  344.   mov ah,[byte(adr)+1]
  345.   and ah,00000010b
  346.   shl ah,5
  347.   and al,10111111b
  348.   or al,ah
  349.   mov ah,al
  350.   mov al,9
  351.   out dx,ax
  352.   end;
  353.  
  354. procedure memBlt(memPage:pointer);external;
  355.  
  356. procedure setWritePage(adr:word);external;
  357. procedure setDisplayPage(adr:word);external;
  358. procedure setWindow(x,y:integer);external;
  359.  
  360. procedure pageFlip;begin  {keep in mind some modes are too big to page flip}
  361.   setDisplayPage(word(pgStart));
  362.   setWritePage(word(pgStart)xor pgBytes);
  363.   end;
  364.  
  365. procedure waitRetrace;external;
  366.  
  367. var oldMode:byte;
  368.  
  369. function setModeX(var tblX,tblY; logX,logY:word):boolean;external;
  370. procedure setText;external;
  371.  
  372. function rgb(r,g,b:byte):byte;begin  {gives index into uniform palette}
  373.   if (r=g)and(g=b) then rgb:=word(r)*31 div 255
  374.   else rgb:=((((word(r)*6+127) div 255)shl 5)or
  375.              ((g shr 5)shl 2)or
  376.               (b shr 6)
  377.             )+32;
  378.   end;
  379.  
  380. procedure set884palette;var y,v,c:word;begin
  381.   port[$3c8]:=0;
  382.   for y:=0 to 255 do begin
  383.     v:=(y and $E0)shr 2; port[$3c9]:=v or(v shr 3);
  384.     v:=y and $1C; port[$3c9]:=(v shl 1)or(v shr 2);
  385.     v:=y and 3; port[$3c9]:=(v shl 4)or(v shl 2)or v;
  386.     end;
  387.   end;
  388. procedure setUniformPalette;var i,j,r,g,b:word;begin
  389.   for i:=0 to 31 do begin j:=i*63 div 31; setColor(i,j,j,j); end;
  390.   for i:=0 to 223 do begin
  391.     b:=i and 3;
  392.     g:=(i shr 2)and 7;
  393.     r:=(i shr 5)and 7;
  394.     setColor(i+32,r*63 div 6,g*63 div 7,b*63 div 3);
  395.     end;
  396.   end;
  397.  
  398. var savedExitProc:pointer;
  399.  
  400. procedure exitModeX; far; begin
  401.   exitProc:=savedExitProc;
  402.   setText;
  403.   write(exitMsg);
  404.   end;
  405.  
  406. begin
  407.  savedExitProc:=exitProc; exitProc:=@exitModeX;
  408.  end.
  409.  
  410.